unit DUnitX.TestCase;
interface
uses MLC.UnitTestFramework, DUnitX.TestNode, Rtti, SBD.Generics, SBD.Messages,
     MLC.MemoryMonitor, DUnitX.RunInstance, DUnitX.TestCaseParameters;

type

TTestCase = class( TTestNode, ITestCase, ITestCaseInternal)
  private
    function  GetEnabled: boolean;
    procedure SetEnabled( Value: boolean);
    function  DisplayName: string;
    function  Parent: ITestProcedure;
    procedure SetDeferredError( const ErMsg: string);
    function  GetDeferredError( var ErMsg: string): boolean;

  protected
    FName: string;
    FProcType: TRttiMethod;
    FData: string;
    FEnabled: boolean;
    FParams: TTestCaseParamProcessor;
    FDeferredError: string;

    function  RequiresPreliminaryLoadCount: boolean;      virtual;
    function  Load: integer;                              override;
    procedure ShutDown;                                   override;
    function  NodeKind: TResultNodeKind;                  override;
    function  Name: string;                               override;
    function  NodeChildren: ISEnumerable<ITestNode>;      override;
    procedure Execute( Platter: TObject);
    function  EstimateRoundCount: integer;                virtual;
    function  MakeRunInstance( ParentAsObject: TReflector; TestBed: TGetObjectFunc; const Mem1: IMemoryMonitor): IRunInstance; virtual;
    function  HasEnabledTestCases: boolean;                                                override;

  public
    constructor CreateCase( ProcParentAsObject: TReflector; ProcType: TRttiMethod; Attri: TestCaseAttribute);
    destructor  Destroy; override;
  end;

TDataDrivenTestCase = class( TTestCase, IDataDrivenTestCase)
  private
    FisLoadCached: boolean;
    FLoad: integer;
    constructor CreateCase( ProcParentAsObject: TReflector; ProcType: TRttiMethod; Attri: DataDrivenTestAttribute);
    function AcquireDataDriver( Platter: TObject): IDataDrivenTestCaseCursor;
  protected
    function  Load: integer;                              override;
    function  RequiresPreliminaryLoadCount: boolean;      override;
    function  EstimateRoundCount: integer;                override;
  end;

TSimpleTestCase = class( TTestCase)
  private
    constructor CreateCase( ProcParentAsObject: TReflector; ProcType: TRttiMethod);
  end;

TTestCaseList = class ( TList2<ITestCase>, ITestCasesInternal, IShutDown)
  public
    function  AddCase( ProcParentAsObject: TReflector; ProcType: TRttiMethod; Attri: TestCaseAttribute): ITestCaseInternal;
    function  AddDataDrivenCase( ProcParentAsObject: TReflector; ProcType: TRttiMethod; Attri: DataDrivenTestAttribute): ITestCaseInternal;
    function  AddSimpleCase( ProcParentAsObject: TReflector; ProcType: TRttiMethod; Attri: TestAttribute): ITestCaseInternal;
    procedure ShutDown;
  end;




TTestCase_RunInstance = class( TTestNode_RunInstanceWithChildren)
  protected
    FDeferredErrorCount: integer;
    FTestCase: ITestCaseInternal;
    FTestBed: TGetObjectFunc;
    FRoundsCompleted: integer;
    FMessages: IMessageList;

    procedure Clear;                        override;
    function  HasMessageList( var Lst: IMessageList): boolean; override;
    function  WorkLoad: integer;            override;
    function  TestNode: ITestNode;          override;
    function  RoundsCompleted: integer;     override;
    function  RoundsPerTestCase: integer;   override;
    function  TestCase: ITestCase;          override;
    function  NodeKind: TResultNodeKind;    override;
    procedure DoInnerRun;                   override;
    function  IgnoredCount: integer;        override;
    function  SkippedCount: integer;        override;
    function  ErrorCount: integer;          override;

  public
    constructor Create( ParentAsObject: TReflector; TestBed: TGetObjectFunc;
                        const Case1: ITestCaseInternal; const Mem1: IMemoryMonitor);
  end;



function HasDataDrivenSignature( TestMeth: TRttiMethod; var isInterfacedForm: boolean): boolean;



implementation






uses Generics.Collections, SysUtils, TypInfo, DUnitX.Utils.XML2, Math,
     SBD.Messages.Solution, DunitX.TestCaseRound, DUnitX.RttiUtils;



function HasDataDrivenSignature( TestMeth: TRttiMethod; var isInterfacedForm: boolean): boolean;
var
  p1, p2: pointer;
begin
result := TAttributes.Has<DataDrivenTestAttribute>( TestMeth) and
          (TestMeth.MethodKind = mkFunction) and
          (Length( TestMeth.GetParameters) = 0) and
          (TestMeth.ReturnType.TypeKind = tkInterface) and
          (TestMeth.ReturnType is TRttiInterfaceType) and
          (

          // 1st form: a function that returns IDataDrivenTestCaseCursor
          IsEqualGUID(
            TRttiInterfaceType( TestMeth.ReturnType).GUID,
            IDataDrivenTestCaseCursor)

                 or

          // 2nd form: a function that returns a generic procedure TDataLoopDriver.
          // TDataLoopDriver = reference to procedure ( var More: boolean);
          (TypeInfo( TDataLoopDriver) = TRttiInterfaceType( TestMeth.ReturnType).Handle)

          );

isInterfacedForm := result and IsEqualGUID( TRttiInterfaceType( TestMeth.ReturnType).GUID,
                                            IDataDrivenTestCaseCursor)
end;




constructor TTestCase.CreateCase(
  ProcParentAsObject: TReflector; ProcType: TRttiMethod; Attri: TestCaseAttribute);
begin
inherited CreateTestNode( ProcParentAsObject);
FName := Attri.FName;
FProcType := ProcType;
FEnabled := Parent.GetDefaultEnabled;
FViewTokens := TDictionary<ITestLogger,IInterface>.Create;
FData   := Attri.FData;
FParams := TTestCaseParamProcessor.Create( FProcType, FData);
FParams.Parse;
if FParams.FParseResult = psSyntaxError then
  raise Exception.Create( '[TestCase] syntax error')
end;

destructor TTestCase.Destroy;
begin
inherited;
FParams.Free
end;

function TTestCase.DisplayName: string;
begin
result := Name
end;

function TTestCase.EstimateRoundCount: integer;
begin
result := Parent.RepeatCount
end;

procedure TTestCase.Execute( Platter: TObject);
begin
FParams.Invoke( Platter)
end;

function TTestCase.GetDeferredError( var ErMsg: string): boolean;
begin
ErMsg := FDeferredError;
result := ErMsg <> ''
end;

function TTestCase.GetEnabled: boolean;
begin
result := FEnabled
end;

function TTestCase.Load: integer;
begin
result := Parent.RepeatCount
end;

function TTestCase.MakeRunInstance(
  ParentAsObject: TReflector; TestBed: TGetObjectFunc; const Mem1: IMemoryMonitor): IRunInstance;
begin
result := TTestCase_RunInstance.Create( ParentAsObject, TestBed, self, Mem1)
end;

function TTestCase.Name: string;
begin
result := FName
end;

function TTestCase.NodeChildren: ISEnumerable<ITestNode>;
var
  Accumulator: ITestNodes;
begin
Accumulator := TTestNodes.Create;
result := Accumulator
end;

function TTestCase.NodeKind: TResultNodeKind;
begin
result := rnTestCase
end;

function TTestCase.Parent: ITestProcedure;
begin
if (not assigned( FParent)) or
   (not Supports( FParent.FController, ITestProcedure, result)) then
  result := nil
end;


function TTestCase.RequiresPreliminaryLoadCount: boolean;
begin
result := False
end;

//    The NUnit format
//    ===================
//    Examples:
//       NUnit 2.5: http://nunit.org/files/testresult_25.txt
//       NUnit 3.0: http://nunit.org/files/testresult_30.txt
//       Will probably go iwth 2.5
//    Schema:
//       NUnit 2.5: http://nunit.org/files/testresult_schema_25.txt
//       ? unknown version at http://www.nunit.org/docs/2.2/files/Results.xsd

procedure TTestCase.SetDeferredError( const ErMsg: string);
begin
FDeferredError := ErMsg
end;

procedure TTestCase.SetEnabled( Value: boolean);
begin
FEnabled := Value
end;

procedure TTestCase.ShutDown;
begin
inherited;
FViewTokens.Clear
end;


{ TDataDrivenTestCase }

constructor TDataDrivenTestCase.CreateCase(
  ProcParentAsObject: TReflector; ProcType: TRttiMethod; Attri: DataDrivenTestAttribute);
begin
inherited CreateTestNode( ProcParentAsObject);
FProcType := ProcType;
FName := Parent.Name;
FEnabled := Parent.GetDefaultEnabled;
FData   := '';
FParams := nil;
FisLoadCached := False;
FLoad         := 1
end;

function TDataDrivenTestCase.EstimateRoundCount: integer;
begin
result := Load
end;

type
TDataLooperCursor = class( TInterfacedObject, IDataDrivenTestCaseCursor)
  private
    FLooper: TDataLoopDriver;
    FMore: boolean;
    function  PrerunLoadEstimate: integer;
    function  Next: boolean;
    procedure TestLineItem( TestBed: TObject);
    function  LineItemDescription: string;
  public
    constructor Create( Looper1: TDataLoopDriver);
    function  RefCount: integer;     // For debug purposes. Remove soon.
  end;


function TDataDrivenTestCase.AcquireDataDriver( Platter: TObject): IDataDrivenTestCaseCursor;
var
  isInterfacedForm: boolean;
  LooperAsIntf: IInterface;
  Looper: TDataLoopDriver;
  More: boolean;
begin
if HasDataDrivenSignature( FProcType, isInterfacedForm) then
    begin
    if isInterfacedForm then
        begin
        result := FProcType.Invoke( Platter, []).AsType<IDataDrivenTestCaseCursor>;
        result._AddRef // <-- This is needed in D2010. TODO: Test if required for other compilers.
        end
      else
        begin
        LooperAsIntf := FProcType.Invoke( Platter, []).AsType<TDataLoopDriver>;
        LooperAsIntf._AddRef; // <-- This is needed in D2010. TODO: Test if required for other compilers.
        Looper := TDataLoopDriver( LooperAsIntf);
        result := TDataLooperCursor.Create( Looper)
        end
    end
  else
    result := nil
end;

function TDataDrivenTestCase.Load: integer;
var
  Obj: TObject;
  Cursor: IDataDrivenTestCaseCursor;
  Fixture: ITestFixtureInternal;
begin
if not FisLoadCached then
  begin
  result := 1;
  try
    FisLoadCached := True;
    FLoad := 1;
    if FDeferredError <> '' then exit;
    if Supports( Parent.Parent, ITestFixtureInternal, Fixture) then
        Obj := Fixture.PreliminaryPlatterObject
      else
        Obj := nil;
    if assigned( Obj) then
        begin
        Fixture.Setup( Obj);
        try
          Cursor := AcquireDataDriver( Obj);
          try
            FLoad := Cursor.PrerunLoadEstimate
          finally
            Cursor := nil
            end
        finally
          Fixture.Teardown( Obj)
          end;
        if FLoad <= 0 then
          begin
          FLoad := 1;
          SetDeferredError( 'Data driven test procedure returned an invalid preliminary load estimate.')
          end
        end
      else
        SetDeferredError( 'Preliminatry load estimate could not be computed due to unavailable test fixture.')
  except on E: Exception do
      begin
      FLoad := 1;
      SetDeferredError( E.Message)
      end
    end
  end;
result := FLoad
end;


function TDataDrivenTestCase.RequiresPreliminaryLoadCount: boolean;
begin
result := not FisLoadCached
end;


{ TSimpleTestCase }

constructor TSimpleTestCase.CreateCase(
  ProcParentAsObject: TReflector; ProcType: TRttiMethod);
begin
inherited CreateTestNode( ProcParentAsObject);
FProcType := ProcType;
FName := FProcType.Name;
FEnabled := Parent.GetDefaultEnabled;
FData   := '';
FParams := TTestCaseParamProcessor.CreateSimple( FProcType)
end;




function TTestCaseList.AddCase( ProcParentAsObject: TReflector;
  ProcType: TRttiMethod; Attri: TestCaseAttribute): ITestCaseInternal;
begin
result := TTestCase.CreateCase( ProcParentAsObject, ProcType, Attri);
Add( result)
end;

function TTestCaseList.AddDataDrivenCase(ProcParentAsObject: TReflector;
  ProcType: TRttiMethod; Attri: DataDrivenTestAttribute): ITestCaseInternal;
begin
result := TDataDrivenTestCase.CreateCase( ProcParentAsObject, ProcType, Attri);
Add( result)
end;

function TTestCaseList.AddSimpleCase(ProcParentAsObject: TReflector;
  ProcType: TRttiMethod; Attri: TestAttribute): ITestCaseInternal;
begin
result := TSimpleTestCase.CreateCase( ProcParentAsObject, ProcType);
Add( result)
end;



procedure TTestCaseList.ShutDown;
var
  Child: ITestCase;
  Shut: IShutDown;
begin
for Child in (self as ITestCasesInternal) do
  if Supports( Child, IShutDown, Shut) then
    Shut.ShutDown
end;






type
TExecOneRoundProc = reference to procedure( Case1: ITestCaseInternal; TestBed1: TObject);
TRepeatRowsCursor = class( TInterfacedObject, IDataDrivenTestCaseCursor)
  private
    FCase: ITestCaseInternal;
    FTestBed: TObject;
    FRounds: integer;
    FExec: TExecOneRoundProc;
    FIdx: integer;

    function  PrerunLoadEstimate: integer;
    function  Next: boolean;
    procedure TestLineItem( TestBed: TObject);
    function  LineItemDescription: string;
    function  RefCount: integer;
  public
    constructor Create( Case1: ITestCaseInternal; TestBed1: TObject; Rounds: integer; Exec: TExecOneRoundProc);
  end;

function TTestCase.HasEnabledTestCases: boolean;
var
  sErr: string;
begin
result := GetEnabled and (not GetDeferredError( sErr))
end;




constructor TRepeatRowsCursor.Create( Case1: ITestCaseInternal; TestBed1: TObject; Rounds: integer; Exec: TExecOneRoundProc);
begin
FCase    := Case1;
FTestBed := TestBed1;
FRounds  := Rounds;
FExec    := Exec;
FIdx     := 0
end;

function TRepeatRowsCursor.LineItemDescription: string;
begin
result := Format( 'round %d', [FRounds])
end;

function TRepeatRowsCursor.Next: boolean;
begin
result := FIdx < FRounds;
if result then
  Inc( FIdx)
end;

function TRepeatRowsCursor.PrerunLoadEstimate: integer;
begin
result := FRounds
end;

function TRepeatRowsCursor.RefCount: integer;
begin
result := self.FRefCount
end;

procedure TRepeatRowsCursor.TestLineItem( TestBed: TObject);
begin
FExec( FCase, FTestBed)
end;




{ TTestCase_RunInstance }

constructor TTestCase_RunInstance.Create(
  ParentAsObject: TReflector;
  TestBed: TGetObjectFunc; const Case1: ITestCaseInternal;
  const Mem1: IMemoryMonitor);
begin
FMessages := TMessageList.Create;
inherited Create( ParentAsObject, Mem1);
FTestCase := Case1;
FTestBed  := TestBed
end;

procedure TTestCase_RunInstance.Clear;
begin
inherited;
FMessages.Clear;
FDeferredErrorCount := 0;
FRoundsCompleted    := 0;
if assigned( FMem) then
  FMem.HeapMonitoring_OFF
end;


procedure TTestCase_RunInstance.DoInnerRun;
var
  TestBedObj: TObject;
  sErr: string;
  j: integer;
  Addend: IRunInstance;
  sIgnoreReason: string;
  DD: IDataDrivenTestCase;
  Cursor: IDataDrivenTestCaseCursor;
begin
TestBedObj := FTestBed();
if FTestCase.Enabled and FTestCase.GetDeferredError( sErr) then
    begin
    FDeferredErrorCount := 1;
    Status := tsError;
    PutSimpleMessage( SyntaxError, sErr, lvError)
    end
  else if FTestCase.Enabled and (not FRunInstanceServices.IsAborted) then
    begin
    if Supports( FTestCase, IDataDrivenTestCase, DD) then
        Cursor := DD.AcquireDataDriver( TestBedObj)
      else
        begin
        Cursor := TRepeatRowsCursor.Create( FTestCase, TestBedObj, RoundsPerTestCase,
          procedure( Case1: ITestCaseInternal; TestBed1: TObject)
          // Called from TTestCaseRound_RunInstance.RawExecute
          begin
          Case1.Execute( TestBed1)
          end)
        end;
	  Status := tsExecuting;
    while Cursor.Next and (not FRunInstanceServices.IsAborted) do
      begin
      Addend := TTestCaseRound_RunInstance.Create( FWeakClients, TestBedObj, FTestCase, FRoundsCompleted, FMem, Cursor);
      FChildren.Add( Addend);
      Addend.Run( FRunInstanceServices,
        procedure ( ChildStatus: TTestStatus)
        begin
        if ChildStatus in [tsPass..tsSkipped] then
          Inc( FRoundsCompleted);
        if ChildStatus in [tsSetup, tsExecuting, tsTeardown] then
          Status := ChildStatus
        end);
      FExecuted := True;
      if ErrorCount > 0 then break
      end;
	  if ErrorCount > 0 then
	    Status := tsError
    else if FailCount > 0 then
	    Status := tsFail
    else if WarnCount > 0 then
	    Status := tsWarn
     else if FRoundsCompleted > 0 then
	     Status := tsPass
     else
       // Skipped because there were no rounds to execute.
       Status := tsSkipped
	  end
  else if FTestCase.Parent.IsIgnored( sIgnoreReason) and (not FRunInstanceServices.IsAborted) then
    begin
    // Skipped because the test case is marked as ignore
    Status := tsSkipped;
    Self.PutSimpleMessage( IgnoredTestCase, sIgnoreReason, lvHint)
    end
  else
    // Skipped because teh test case is disabled (but not ignored) or user aborted
    Status := tsSkipped
end;

function TTestCase_RunInstance.ErrorCount: integer;
begin
result := FDeferredErrorCount + inherited ErrorCount
end;

function TTestCase_RunInstance.HasMessageList(var Lst: IMessageList): boolean;
begin
result := True;
Lst    := FMessages
end;

function TTestCase_RunInstance.IgnoredCount: integer;
// The ignored count of a test case is ...
//  If the status is skipped and the test proc is marked as Ignore, then it is RoundsPerTestCase.
//  Otherwise it is zero.
var
  sIgnoreReason: string;
begin
if (FStatus = tsSkipped) and FTestCase.Parent.IsIgnored( sIgnoreReason) then
    result := RoundsPerTestCase
  else
    result := 0
end;

function TTestCase_RunInstance.NodeKind: TResultNodeKind;
begin
result := rnTestCase
end;

function TTestCase_RunInstance.RoundsCompleted: integer;
begin
result := FRoundsCompleted
end;

function TTestCase_RunInstance.RoundsPerTestCase: integer;
begin
result := Max( FTestCase.EstimateRoundCount, FChildren.Count)
end;

function TTestCase_RunInstance.SkippedCount: integer;
// The skip count of a test case is ...
//  If the status is some kind of done (pass, fail, error, skip) then
//   it is the remainder (RoundsPerTestCase - passes - fails - errors - ignores)
//  Otherwise it is zero
begin
if FStatus in [tsPass..tsSkipped] then
    result := RoundsPerTestCase - PassCount - FailCount - ErrorCount - IgnoredCount
  else
    result := 0
end;

function TTestCase_RunInstance.TestCase: ITestCase;
begin
result := FTestCase
end;

function TTestCase_RunInstance.TestNode: ITestNode;
begin
result := FTestCase as ITestNode
end;

function TTestCase_RunInstance.WorkLoad: integer;
begin
if FTestCase.Enabled then
    result := RoundsPerTestCase
  else
    result := 0
end;

{ TDataLooperCursor }

constructor TDataLooperCursor.Create( Looper1: TDataLoopDriver);
begin
FLooper := Looper1;
FMore   := assigned( FLooper)
end;

function TDataLooperCursor.LineItemDescription: string;
begin
result := ''
end;

function TDataLooperCursor.Next: boolean;
begin
result := FMore
end;

function TDataLooperCursor.PrerunLoadEstimate: integer;
begin
result := 1
end;

function TDataLooperCursor.RefCount: integer;
begin
result := inherited RefCount
end;

procedure TDataLooperCursor.TestLineItem( TestBed: TObject);
begin
if assigned( FLooper) then
    FLooper( TestBed, FMore)
  else
    FMore := False
end;

end.
